(* ===================================================================== *)
(** Utilitaires Verilog : traduction de net-list .bop vers une net-list 
    en verilog structurel, et production de tests_benches en macro.
    @author Mathieu Barbin
    @version 1.0.* *)
(* ===================================================================== *)

(*
#load "unix.cma";;
#load "graphics.cma";;
#load "bplib.cma";;
*)

open Bplib
open ListMap
open Inputtools
open Circuit
open Cdsmaker
open Bop2tools


(** 
    Contrairement a bop2c, bop2vlog travaille au niveau de la net-list .bop
    uniquement. Les net-list precompilees bpx ne sont pas exploitables.
    
    La raison est d'assurer une certaine coherence entre les 2 fichiers, 
    en essayant de preserver les identifiants choisis dans le fichier .bop,
    et le decoupage par blocs.

    Les fichiers produits necessitent peut etre une relecture mano avant de 
    pouvoir bien fonctionner sous iverilog ou cver. (voir tutos, et note dans 
    le manuel)

    A partir de l'analyse de la net list, on va avec un fold creer l'environnement
    complet avec verifications de contextes, avant la production du code. 
    A chaque fonction debouclee, correspond un module verilog.

<h2> Quelques types pour gerer des sources verilog </h2> *)

(* ===================================================================== *)
(** module verilog : c'est le type contenu dans l'environnement *)
type vlog_module =
    {
      (* contient des appels a des blocs necessitant 'clock' *)
      synchrone : bool;
      (* entete : interface + variables *)
      vlog_entete : vlog_entete;
      (* corps *)
      vlog_instances : vlog_instance list;
      (* processes *)
      vlog_initial : vlog_task list;
      vlog_posedge_clk : vlog_task list;
      vlog_always : vlog_task list
    }
and vlog_entete =
    {
      vlog_i_name  : string;
      vlog_i_output : vlog_interface;
      vlog_i_input : vlog_interface;
      (** on laisse la possibilite d'avoir des tableaux dans les reg et wire *)
      vlog_i_reg : vlog_signal list;
      vlog_i_wire : vlog_signal list
    }
and vlog_instance =  
  | ASSIGN of vlog_call_signal * vlog_op_signal            (** assign dest = src; *)
  | INSTCALL of string * string * vlog_call_signal list * vlog_call_signal list (** name node%d (signals_out, signals_in); *)
  | IGNORED_TASK of string (** system task bebop ignoree par la compilation *)
and vlog_task =
  | TIMED of (int * vlog_task)
  | ASSIGN_BLOC (* = *) of vlog_call_signal * vlog_op_signal
  | ASSIGN_NON_BLOC (* <= *) of vlog_call_signal * vlog_op_signal
  | SYSTASK of string * vlog_arg list
  | OTHER_TASK of string
and vlog_arg = STRING_ARG of string | SIGNAL_ARG of vlog_call_signal
and 'a param_vlog_signal = 
  | SIGNAL of string
  | VECTOR of string * bool * 'a (* nom * si l'appel correspond a la declaration *) 
  | CONCAT of ('a param_vlog_signal) list
and vlog_signal = (vlog_indexation list) param_vlog_signal
and vlog_call_signal = vlog_indexation param_vlog_signal
and vlog_op_signal =
  | ID of vlog_call_signal
  | NOT of vlog_call_signal
  | VDD of int
  | GND of int
  | OTHER of string (* what doesn't go somewhere else like su = su + 1 *)  
and vlog_indexation =
  | INTERVAL of (int * int) 
  | INDEX of int
and vlog_interface = vlog_interface_signal list
and vlog_interface_signal = WIRE of string | BUS of string * (int * int)

(** Le resultat de la traduction des fonctions debouclees. Pour pouvoir faire aussi les verifications de contexte
    on creer en meme temps l'environnement bebop *)
type verilog_traduction =
    {
      bebop_env : fonction_description StringMap.t; (** environnement bebop *)
      vlog_env : vlog_module StringMap.t; (** environnement complet *)
      vlog_fcts_order : string list;    (** l'ordre de declaration du premier au dernier *)
    } 
(* ===================================================================== *)

(* ===================================================================== *)
(** Comparaison lexicographique generique entre 2 listes *)
(* ===================================================================== *)
let compare_generic_list cmp =
  let rec aux a b =
    match a, b with
    | [], [] -> 0
    | t::q, [] -> 1
    | [], t::q -> -1
    | t1::q1, t2::q2 ->
	let g = cmp t1 t2 in
	if g <> 0 
	then g
	else aux q1 q2
  in aux
(* ===================================================================== *)

(* ===================================================================== *)
(** Gestion de Set ou Map de vlog_signal : necessite un VlogSignalCmp *)
(* ===================================================================== *)
module VlogCmpTools =
struct

  let cmp_vlog_indexation vi1 vi2 =
    match vi1, vi2 with
    | INDEX _, INTERVAL _ -> (-1)
    | INTERVAL _, INDEX _ -> 1
    | INDEX a, INDEX b -> Pervasives.compare a b
    | INTERVAL (a, b) , INTERVAL (c, d) -> 
	let g = Pervasives.compare a c in
	if g <> 0
	then g
	else Pervasives.compare b d

  let cmp_param_vlog_signal cmp_a =
    let rec aux pvs1 pvs2 =
      match pvs1, pvs2 with
      | SIGNAL _, VECTOR _ -> (-1)
      | SIGNAL _, CONCAT _ -> (-1)
      | VECTOR _, CONCAT _ -> (-1)
      | VECTOR _, SIGNAL _ -> 1
      | CONCAT _, SIGNAL _ -> 1
      | CONCAT _, VECTOR _ -> 1
	  (* Cas d'egalite *)
      | SIGNAL s1, SIGNAL s2 -> String.compare s1 s2
      | VECTOR (name1, _, a1) , VECTOR (name2, _, a2) ->
	  let g = String.compare name1 name2 in
	  if g <> 0
	  then g
	  else
	    cmp_a a1 a2
      | CONCAT list1 , CONCAT list2 -> compare_generic_list aux list1 list2
    in aux

  let cmp_vlog_signal = cmp_param_vlog_signal (compare_generic_list cmp_vlog_indexation)

  let cmp_vlog_call_signal = cmp_param_vlog_signal cmp_vlog_indexation
end

module VlogSignalCmp : (Set.OrderedType with type t = vlog_signal) =
struct
  type t = vlog_signal
  let compare = VlogCmpTools.cmp_vlog_signal
end

module VlogSignalSet = Set.Make (VlogSignalCmp)

let vlog_signal_set_of_list = List.fold_left (fun accu t -> VlogSignalSet.add t accu)

module VlogCallSignalCmp : (Set.OrderedType with type t = vlog_call_signal) =
struct
  type t = vlog_call_signal
  let compare = VlogCmpTools.cmp_vlog_call_signal
end

module VlogCallSignalSet = Set.Make (VlogCallSignalCmp)

let vlog_call_signal_set_of_list = List.fold_left (fun accu t -> VlogCallSignalSet.add t accu)  
(* ===================================================================== *)

(* ===================================================================== *)
(** Compter les signaux en nombre de bits *)
(* ===================================================================== *)
module Count =
struct
  let signal (sign:vlog_signal) =
    let f_fold_index accu = function
      | INTERVAL (a, b) -> accu * ( (abs (a-b)) + 1)
      | INDEX _ -> accu
    in
    let rec aux = function
      | SIGNAL _ -> 1
      | VECTOR (_, _, vli_list) -> List.fold_left f_fold_index 1 vli_list
      | CONCAT vlsig_list -> List.fold_left (fun a s -> a + aux s) 0 vlsig_list
    in aux sign
	 
  let rec call_signal:vlog_call_signal -> int = function
    | SIGNAL _ -> 1
    | VECTOR (_, _, INTERVAL (a, b)) -> (abs (a-b)) + 1
    | VECTOR (_, _, INDEX _ ) -> 1
    | CONCAT sig_list -> List.fold_left (fun a s -> a + call_signal s) 0 sig_list
	
  let interface_signal = function
    | WIRE _ -> 1
    | BUS (_, (a, b)) -> (abs (a-b)) + 1
	
  (** dans le cas d'une liste *)
  let signal_list = 
    let f_fold accu s = accu + (signal s) in
    List.fold_left f_fold 0
      
  let call_signal_list = 
    let f_fold accu s = accu + (call_signal s) in
    List.fold_left f_fold 0
      
  let interface_signal_list =
    let f_fold accu s = accu + (interface_signal s) in
    List.fold_left f_fold 0
end
(* ===================================================================== *)

(* ===================================================================== *)
(** Concatener des signaux, acceder aux noms, etc.. *)
(* ===================================================================== *)
let concat_vlog_sign vs1 vs2 = 
  match vs1, vs2 with
  | CONCAT v1, CONCAT v2 -> CONCAT (v1@v2)
  | CONCAT v1, other -> CONCAT (v1@[other])
  | other, CONCAT v2 -> CONCAT (other::v2)
  | other1, other2 -> CONCAT [other1; other2]

let name_of_signal = function
  | SIGNAL s -> s
  | VECTOR (s, _, _) -> s
  | CONCAT _ -> failwith "name_of_signal"
      
let name_of_interface_signal = function
  | WIRE s -> s
  | BUS (b, _) -> b

(* ===================================================================== *)
(** Transtypage d'un vlog_call_signal vers un signal verilog : declaration *) 
(* ===================================================================== *)
let vlog_call_signal_of_interface_signal = function  
  | BUS (nom, index) -> VECTOR (nom , true, INTERVAL index)
  | WIRE s -> SIGNAL s

let vlog_interface_signal_of_call_signal = function
  | VECTOR (nom, _, INTERVAL index) -> BUS (nom, index)
  | VECTOR (nom, _, INDEX i) -> BUS (nom, (i, i))
  | SIGNAL i -> WIRE i
  | CONCAT _ -> failwith "Du CONCAT rendu pour l'interface dans vlogtools"

let rec vlog_signal_of_call_signal = function
  | SIGNAL t -> SIGNAL t
  | VECTOR (s, b, ind) -> VECTOR (s, b, [ind])
  | CONCAT list -> CONCAT (List.map vlog_signal_of_call_signal list)
(* ===================================================================== *)


(* ===================================================================== *)
(** Vers la Syntaxe concrete de verilog *)
(* ===================================================================== *)
module VlogSyntax =
struct
  let of_indexation = function
    | INTERVAL (a, b) -> Printf.sprintf "[%d:%d]" b a (* reverse bit because of LSB convention in bebop *)
    | INDEX a -> Printf.sprintf "[%d]" a

  let rec declaration_of_signal : vlog_signal -> string = function
    | SIGNAL s -> s
    | VECTOR (s, _, ilist) -> 
	let rec aux accu = function
	  | [] -> accu
	  | [t] -> (of_indexation t)^" "^accu
	  | t::q -> aux (accu^" "^(of_indexation t)) q
	in aux s ilist
    | CONCAT _ -> failwith "CONCAT in declaration_of_signal"

  let rec declaration_of_interface_signal : vlog_interface_signal -> string = function
    | WIRE s -> s
    | BUS (s, t) -> (of_indexation (INTERVAL t))^" "^s

  let rec of_call_signal : vlog_call_signal -> string = function
    | SIGNAL s -> s
    | VECTOR (s, dec, index) -> if dec then s else Printf.sprintf "%s%s" s (of_indexation index)
    | CONCAT vslist -> 
	begin
	  match vslist with
	  | [t] -> of_call_signal t
	  | _ -> string_of_list of_call_signal ", " "{" "}" vslist
	end

  let of_op_signal = function
    | ID vs -> of_call_signal vs
    | NOT vs -> Printf.sprintf "~%s" (of_call_signal vs)
    | VDD i -> if i = 1 then "1" else Printf.sprintf "%d'b1" i
    | GND i -> if i = 1 then "0" else Printf.sprintf "%d'b0" i
    | OTHER ot -> ot  

  let of_instance = function
   | ASSIGN (v, v2) -> Printf.sprintf "assign %s = %s;" (of_call_signal v) (of_op_signal v2)
   | INSTCALL (bloc, node, outp, inp) -> Printf.sprintf "%s %s %s;" bloc node (string_of_list of_call_signal ", " "(" ")" (outp@inp))
   | IGNORED_TASK s -> Printf.sprintf "// BEBOP System task : %s" s

 let of_arg = function
   | STRING_ARG s -> Printf.sprintf "\"%s\"" s
   | SIGNAL_ARG v -> of_call_signal v

 let rec of_task = function
   | TIMED (i, v) -> Printf.sprintf "#%d %s" i (of_task v)
   | ASSIGN_BLOC (v, v2) -> Printf.sprintf "%s = %s;" (of_call_signal v) (of_op_signal v2)
   | ASSIGN_NON_BLOC (v, v2) -> Printf.sprintf "%s <= %s;" (of_call_signal v) (of_op_signal v2) 
   | SYSTASK (s, arglist) -> Printf.sprintf "$%s%s;" s (string_of_list of_arg ", " "(" ")" arglist) 
   | OTHER_TASK d -> d

 let of_entete i =
   let out = ref "" in
   let prod s = if s = "" then () else out := (!out)^s^"\n" in
   let entete = Printf.sprintf "module %s%s;" i.vlog_i_name (string_of_list name_of_interface_signal ", " "(" ")" (i.vlog_i_output@i.vlog_i_input)) in
   let declaration_interface key_word list = 
     let rec aux accu_simple others = function
       | [] -> 
	   Printf.sprintf "%s%s"
	     (
	       match accu_simple with
	       | [] -> ""
	       | els -> Printf.sprintf "\t%s %s;" key_word (string_of_list (fun t -> t) ", " "" "" accu_simple) 
	     )
	     (
	       match others with
	       | [] -> ""
	       | els -> string_of_list (fun t -> t) "\n" (match accu_simple with [] -> "" | _ -> "\n")  "" els
	     )
       | (WIRE s)::q -> aux (s::accu_simple) others q
       | ((BUS _) as v)::q -> aux accu_simple ((Printf.sprintf "\t%s %s;" key_word (declaration_of_interface_signal v))::others) q
     in 
     match list with
     | [] -> ""
     | els -> aux [] [] els 
   in
   let declaration_vars key_word list = 
     let rec aux accu_simple others = function
       | [] -> 
	   Printf.sprintf "%s%s"
	     (
	       match accu_simple with
	       | [] -> ""
	       | els -> Printf.sprintf "\t%s %s;" key_word (string_of_list (fun t -> t) ", " "" "" accu_simple) 
	     )
	     (
	       match others with
	       | [] -> ""
	       | els -> string_of_list (fun t -> t) "\n" (match accu_simple with [] -> "" | _ -> "\n")  "" els
	     )
       | (SIGNAL s)::q -> aux (s::accu_simple) others q
       | ((VECTOR _) as v)::q -> aux accu_simple ((Printf.sprintf "\t%s %s;" key_word (declaration_of_signal v))::others) q
       | _ -> failwith "concat in declaration_of_module"	   
     in 
     match list with
     | [] -> ""
     | els -> aux [] [] els 
   in
   let declaration_input = declaration_interface "input" i.vlog_i_input in
   let declaration_output = declaration_interface "output" i.vlog_i_output in
   let declaration_reg = declaration_vars "reg" i.vlog_i_reg in
   let declaration_wire = declaration_vars "wire" i.vlog_i_wire in
   prod entete;
   (* prod "// Input"; *)
   prod declaration_input;
   (* prod "// Output"; *)
   prod declaration_output;
   (* prod "// Local signals"; *)
   prod declaration_reg;
   prod declaration_wire;
   (* rendu *)
   !out
   
 let of_module m =
   let out = ref "" in
   let prod s = if s = "" then () else out := (!out)^s^"\n" in
   begin
     (* entete *)
     let entete = of_entete m.vlog_entete in
     (* instances *)
     let instances = 
       let rec aux accu = function
	 | [] -> accu
	 | [t] -> accu^"\t"^(of_instance t)
	 | t::q -> aux (Printf.sprintf "%s\t%s\n" accu (of_instance t)) q
       in 
       match m.vlog_instances with
       | [] -> ""
       | els -> aux "" els 
     in

     (* processes *)
     let task_group event = function
       | [] -> ""
       | [t] -> Printf.sprintf "\t%s %s" event (of_task t)
       | oth -> Printf.sprintf "\t%s begin\n%send" event (List.fold_left (fun accu t -> accu^"    "^(of_task t)^"\n") "" oth) 
     in
     let initial = task_group "initial" m.vlog_initial in
     let posedge_clk = task_group "always @(posedge clock)" m.vlog_posedge_clk in
     let always = task_group "always" m.vlog_always in
     
     (* production *)
     prod entete;
     (* prod "// Struct"; *)
     prod instances;
     (* prod "\n// Process"; *)
     prod initial;
     prod posedge_clk;
     prod always;
     prod "endmodule";
     (* return *)
     !out
   end
end 
(* ===================================================================== *)

(* ===================================================================== *)
(** Expancier les vecteurs jusqu'a la derniere composante *)
(* ===================================================================== *)
let expand_vlog_indexation indexation = 
  let index_fun = (fun i -> INDEX i) in
  match indexation with
  | INDEX i -> [INDEX i]
  | INTERVAL (a, b) ->
      if a <= b
      then expand_list_croissant index_fun a b
      else expand_list_decroissant index_fun a b

let expand_vlog_index_list = expand_index_list_gen (Printf.sprintf "_%d_")
  
let mono_dim_vector_list name int_index_list : string list * indexation_constante =
  match List.rev int_index_list with
  | [] -> failwith "mono_dim_vector_list"
  | [t] -> [name], t
  | t::q -> 
      let first_index = List.rev q in
      let expand = expand_vlog_index_list first_index in
      (List.map (fun s -> name^s) expand), t
(* ===================================================================== *)


(* ===================================================================== *)
(** Des modules verilog pour des primitives bebop *)
(* ===================================================================== *)
module VlogModules =
struct
  let bebop_reg =
    let output = [WIRE "q"] and input = [WIRE "d"; WIRE "clock"] in
    let reg = [SIGNAL "q"] in
    {
      synchrone = true;
      (* entete *)
      vlog_entete =
	{
	  vlog_i_name = "bebop_reg";
	  vlog_i_output = output;
	  vlog_i_input = input;
	  vlog_i_reg = reg;
	  vlog_i_wire = [];
	};
      (* corps *)
      vlog_instances = [];
      (* processes *)
      vlog_initial = [ASSIGN_BLOC (SIGNAL "q", GND 1)];
      vlog_posedge_clk = [ASSIGN_NON_BLOC (SIGNAL "q", ID (SIGNAL "d"))];
      vlog_always = []
    }

  let bebop_mux = 
    {
      synchrone = false;
      vlog_entete =
	{
	  vlog_i_name = "bebop_mux";
	  vlog_i_output = [ WIRE "out" ];
	  vlog_i_input = [ WIRE "en"; WIRE "vdd_in"; WIRE "gnd_in" ];
	  vlog_i_reg = [];
	  vlog_i_wire = [ SIGNAL "out" ];
	};
      vlog_instances = [ASSIGN (SIGNAL "out", OTHER "(en == 1) ? vdd_in : gnd_in") ];
      vlog_initial = [];
      vlog_posedge_clk = [];
      vlog_always = []
    }

  let all = [bebop_reg; bebop_mux]

  let asynch_rom name ad wl filelist = 
    let len = 2 $$ ad in
    {
      synchrone = false;
      vlog_entete =
	{
	  vlog_i_name = name;
	  vlog_i_output = [ BUS ("word", (0, pred wl)) ];
	  vlog_i_input = [ BUS ("addr", (0, pred ad)) ; WIRE "clock" ];
	  vlog_i_reg = [VECTOR ("mem", true, [INTERVAL (pred len, 0) ; INTERVAL (0, pred wl) ] )];
	  vlog_i_wire = [];
	};
      vlog_instances = [ ASSIGN (SIGNAL "word", OTHER "mem[addr]")];
      vlog_initial = [ SYSTASK ("readmemb", [STRING_ARG filelist; SIGNAL_ARG (SIGNAL "mem")] )];
      vlog_posedge_clk = [];
      vlog_always = []
    }

  let synch_rom name ad wl filelist =
    let len = 2 $$ ad in
    let words = 
      let expands = expand_vlog_indexation (INTERVAL (0, pred wl)) in
      CONCAT (List.map (fun index -> VECTOR ("word", false, index)) expands)
    in
    {
      synchrone = true;
      vlog_entete =
	{
	  vlog_i_name = name;
	  vlog_i_output = [ BUS ("word", (0, pred wl)) ];
	  vlog_i_input = [ BUS ("addr", (0, pred ad)) ; WIRE "clock" ];
	  vlog_i_reg = [ VECTOR ("word", true, [INTERVAL (0, pred wl) ]); VECTOR ("mem", true, [INTERVAL (pred len, 0) ; INTERVAL (0, pred wl) ] )];
	  vlog_i_wire = [];
	};
      vlog_instances = [];
      vlog_initial = [ SYSTASK ("readmemb", [STRING_ARG filelist; SIGNAL_ARG (SIGNAL "mem")] )];
      vlog_posedge_clk = [ ASSIGN_NON_BLOC (words, OTHER "mem[addr]") ];
      vlog_always = []
    }

  let synch_ram name ad wl filelist =
    let len = 2 $$ ad in
    let words = 
      let expands = expand_vlog_indexation (INTERVAL (0, pred wl)) in
      CONCAT (List.map (fun index -> VECTOR ("word", false, index)) expands)
    in
    {
      synchrone = true;
      vlog_entete =
	{
	  vlog_i_name = name;
	  vlog_i_output = [ BUS ("word", (0, pred wl)) ];
	  vlog_i_input = [ BUS ("read_addr", (0, pred ad)); 
			   BUS ("write_addr", (0, pred ad)); 
			   WIRE "en";
			   BUS ("data", (0, pred wl));
			   WIRE "clock" ];
	  vlog_i_reg = [ VECTOR ("mem", true, [INTERVAL (pred len, 0) ; INTERVAL (0, pred wl) ] )];
	  vlog_i_wire = [];
	};
      vlog_instances = [ ASSIGN (words, OTHER "mem[read_addr]")];
      vlog_initial = [ SYSTASK ("readmemb", [STRING_ARG filelist; SIGNAL_ARG (SIGNAL "mem")] )];
      vlog_posedge_clk = [ OTHER_TASK "if (en) mem[write_addr] = data;" ]; (* HOOK ? <= ? *)
      vlog_always = []
    }

  (* une ram sans initialisation *)
  let free_synch_ram name ad wl =
    let len = 2 $$ ad in 
    let words = 
      let expands = expand_vlog_indexation (INTERVAL (0, pred wl)) in
      CONCAT (List.map (fun index -> VECTOR ("word", false, index)) expands)
    in
    {
      synchrone = true;
      vlog_entete =
	{
	  vlog_i_name = name;
	  vlog_i_output = [ BUS ("word", (0, pred wl)) ];
	  vlog_i_input = [ BUS ("read_addr", (0, pred ad)); 
			   BUS ("write_addr", (0, pred ad)); 
			   WIRE "en";
			   BUS ("data", (0, pred wl));
			   WIRE "clock" ];
	  vlog_i_reg = [ VECTOR ("mem", true, [INTERVAL (pred len, 0) ; INTERVAL (0, pred wl) ] )];
	  vlog_i_wire = [];
	};
      vlog_instances = [ ASSIGN (words, OTHER "mem[read_addr]")];
      vlog_initial = []; 
      vlog_posedge_clk = [ OTHER_TASK "if (en) mem[write_addr] = data;" ]; (* HOOK ? <= ? *)
      vlog_always = []
    }

end
(* ===================================================================== *)


(*
;;
 print_endline (VlogSyntax.of_module VlogModules.bebop_reg) ;;
print_endline (VlogSyntax.of_module VlogModules.bebop_mux);;

let dec7 =  (VlogModules.asynch_rom "ROM_Dec7" 4 7 "dec7file.list");;
print_endline (VlogSyntax.of_module (VlogModules.asynch_rom "ROM_Dec7" 4 7 "dec7file.list"));;

print_endline (VlogSyntax.of_module (VlogModules.synch_rom "ROM_Dec7" 4 7 "dec7file.list"));;
print_endline (VlogSyntax.of_module (VlogModules.synch_ram "RAM_Dec7" 4 8 "dec7file.list"));;

*)


(* ===================================================================== *)
(** Le relooking d'interface est un sport inconnu chez bebop. Il provient du
    fait que verilog connait des restrictions dans les branchements structurels
    comme conserver le nombre, le sens, le type des arguments bus, wire, etc.. 
    Dans des cas ou on ne s'en sort pas, on leve un Relook_error *)
(* ===================================================================== *)
exception Relook_error of string

let relook_vlog_signal_list vlog_interface vlog_call_signal_list =  
  (* deja, s'il n'ont pas la meme taille, il n'y a aucune chance *)
  let num_expected = Count.interface_signal_list vlog_interface 
  and num_received = Count.call_signal_list vlog_call_signal_list in
  if num_expected <> num_received
  then raise (Relook_error "count diff by signals relooking")
  else
    (* on va utiliser une fonction de reponse a requete qui epuise au fur 
       et a mesure sa reserve en signaux d'entree *)
    let rec input_request reserve sig_expected = (* reserve_restante, vlog_signal *) 
      match reserve with
      | [] -> raise (Relook_error "empty reserve by signals relooking")
      | top::q ->
	  begin
	    match sig_expected, top with 
	      
	    (* 0) desassemblage d'une concatenation (eventuellement pour reassemblage) *)
	    | _, CONCAT list -> input_request (list@q) sig_expected
		
	    (* 1) cas non reprise de q *)
	    | WIRE _ , SIGNAL _ | WIRE _, VECTOR (_, _, INDEX _) -> q, top 
	    | WIRE wir, VECTOR (name, _, INTERVAL (a, b)) ->
		(* selon le sens qui va de a vers b ou de b vers a *)
		if a = b
		then (q, VECTOR (name, false, INDEX a))
		else (* on en remet un peu dans la reserve : le vecteur n'est donc plus sous sa forme de declaration *)
		  if a < b
		  then 
		    begin
		      Printf.fprintf stderr "[W!] %s <- %s[%d] next : %s[%d..%d])\n" wir name a name (succ a) b; flush stderr;
		      ((VECTOR (name, false, INTERVAL (succ a, b)))::q), VECTOR (name, false, INDEX a)
		    end 
		  else 
		    begin
		      Printf.fprintf stderr "[W!] %s <- %s[%d] next : %s[%d..%d]\n" wir name a name (pred a) b; flush stderr;
		      ((VECTOR (name, false, INTERVAL (pred a, b)))::q), VECTOR (name, false, INDEX a)
		    end
	    (* 2) cas avec reprise recursive de q *)
	    | BUS (name, (a, b)), SIGNAL _ | BUS (name, (a, b)), VECTOR (_, _, INDEX _) ->
		if a = b
		then q, top
		else
 		  if a < b
		  then 
		    (* il faut puiser de nouveau dans la reserve *)
		    let new_reserve, new_sig = input_request q (BUS (name, (succ a, b))) in
		    new_reserve, concat_vlog_sign top new_sig
		  else (* a > b *)
		    let new_reserve, new_sig = input_request q (BUS (name, (pred a, b))) in
		    new_reserve, concat_vlog_sign top new_sig

	    (* 3) cas mixtes *)
	    | BUS (busname, (a, b)), VECTOR (vectorname, _, INTERVAL (c, d)) ->
		(* on est en presence d'un interval ici, il faut verifier son sens : dans le cas reverse, il faut retourner l'ordre *)
		let len1 = (abs (a - b)) + 1 and len2 = (abs (c - d)) + 1 in
		if len1 = len2
		then q, top
		else 
		  if len1 < len2
		  then 
		      (* on en demande moins que ce qu'il y en a : on doit donc remettre en reserve *)
		      if c <= d
		      then 
			begin
			  Printf.fprintf stderr "[W!] %s[%d..%d] <- %s[%d..%d] next %s[%d..%d]\n" busname a b vectorname c (c+len1-1) vectorname (c+len1) d;
			  flush stderr;
			  ((VECTOR (vectorname, false, INTERVAL (c + len1, d)))::q), VECTOR (vectorname, false, INTERVAL (c, c + len1 - 1)) 
			end
		      else 
			begin
			  Printf.fprintf stderr "[W!] %s[%d..%d] <- %s[%d..%d] next %s[%d..%d]\n" busname a b vectorname c (c - len1 +1) vectorname (c-len1) d;
			  flush stderr;
			  ((VECTOR (vectorname, false, INTERVAL (c - len1, d)))::q), VECTOR (vectorname, false, INTERVAL (c, c - len1 + 1))
			end		  
		  else (* len1 > len2 *)
		    (* on en demande plus que ce qu'il y en a : on doit reprendre recursivement dans q *)
		    (* Ce cas est terrible dans le cas de vecteurs, il faut surement inverser les arguments ... *)
		    if a <= b
		    then 
		      begin
			Printf.fprintf stderr "[W!] %s[%d..%d] <- %s[%d..%d] next %s[%d..%d] <- ?\n" busname a (a+len2-1) vectorname c d busname (a+len2) b; 
			flush stderr;
			let new_reserve, new_sig = input_request q (BUS (busname, (a+len2, b))) in
			new_reserve, concat_vlog_sign new_sig top (* swap : to test *)
		      end		     
		    else
		      begin
			Printf.fprintf stderr "[W!] %s[%d..%d] <- %s[%d..%d] next %s[%d..%d] <- ?\n" busname b (a-len2+1) vectorname c d busname (a-len2) b; 
			flush stderr;
			let new_reserve, new_sig = input_request q (BUS (busname, (a-len2, b))) in
			new_reserve, concat_vlog_sign new_sig top (* swap : to see *)
		      end 
	  end
    in 
    list_fold_map input_request vlog_call_signal_list vlog_interface
(* ===================================================================== *)


(* ===================================================================== *)
(** On a besoin d'une structure de donnee capable d'indiquer quelles substitutions
    a faire lors de la traduction du code bebop vers vhdl *)
(* ===================================================================== *)
type 'a string_int_map = ('a IntMap.t) StringMap.t

type subst_data = 
    {
      subst_map : subst_struct string_int_map; (** nom puis dimension *)
      mutable local_wire : vlog_signal list 
    }
and subst_struct = SIMPLE_subst of simple_subst | VECTOR_subst of vector_subst
and simple_subst =
    {
      subst_name : string
    }
and vector_subst = (** Tous les vecteurs sont declarés [n-1:0] et sont croissants *)
    {
      subst_vector_name : string;
      mutable vector_min : int;
      mutable vector_max : int
    }
(* ===================================================================== *)

(* ===================================================================== *)
(** Obtenir un vlog_signal a partir d'un susbst_struct *)
(* ===================================================================== *)
let vlog_call_signal_of_subst_struct = function
  | SIMPLE_subst sb -> SIGNAL sb.subst_name
  | VECTOR_subst vs -> VECTOR (vs.subst_vector_name, true, INTERVAL (vs.vector_min, vs.vector_max))
(* ===================================================================== *)

(* ===================================================================== *)
(** Ajouter les elements d'un vlog_indexation dans un vector_subst.
    Fonctionne par effet de bord sur les champs mutables *)
(* ===================================================================== *)
let index_belong_to_vector_subst index vs =
  if index = vs.vector_min then true
  else 
    if index > vs.vector_min
    then index <= vs.vector_max
    else false

let insert_vlog_indexation_in_vector_subst vlog_index vs =
  match vlog_index with
  | INDEX i -> 
      if i > vs.vector_max 
      then vs.vector_max <- i
      else 
	if i < vs.vector_min
	then vs.vector_min <- i
	else ()
  | INTERVAL (a, b) ->
      begin
	(* deuxiemement, on s'occupe de mettre a jour les bornes *)
	let minab = min a b and maxab = max a b in
	if minab < vs.vector_min
	then vs.vector_min <- minab
	else ();
	if maxab > vs.vector_max
	then vs.vector_max <- maxab
	else ()
      end 	
(* ===================================================================== *)


(* ===================================================================== *)
(** Passer d'un indexation vers une vlog_indexation *)
(* ===================================================================== *)
let vlog_indexation_of_int_param_indexation = function
| SegmentInit i -> if i > 0 then INTERVAL (0, pred i) else INTERVAL (pred (-i), 0)
| Intervalle (a, b) -> INTERVAL (a, b) 
| Index a -> INDEX a
(* ===================================================================== *)

(* ===================================================================== *)
(** Barrière d'abstraction pour l'utilisation de la substitution *)
(* ===================================================================== *)
module SubstMap =
struct
  (** La map vide *)
  let (empty:subst_data) = 
    {
      local_wire = [];
      subst_map = StringMap.empty;
    }

  (** Acces a l'ensemble de tous les VlogSignal contenus dans une map *)
  (* c'est un double fold avec comme accu un set *)
  let get_all_vlog_call_signal map =
    let fold_int_map _ valu accu = VlogCallSignalSet.add (vlog_call_signal_of_subst_struct valu) accu in
    let fold_string_map _ valu accu = IntMap.fold fold_int_map valu accu in
    StringMap.fold fold_string_map map.subst_map VlogCallSignalSet.empty
    
  (** Acces aux dimensions presentes *)
  let find_dim name map =
    try
      let intm = StringMap.find name map.subst_map in
      let elements_fold s _ accu = s::accu in
      IntMap.fold elements_fold intm []
    with
    | Not_found -> []

  (** ajouter une subst_struct a partir du nom et de la dimension *)
  let add name dim subst subst_data =
    let accu = subst_data.subst_map in
    let already = 
      try
	StringMap.find name accu
      with
      | Not_found -> IntMap.empty
    in
    let ii = IntMap.add dim subst already in
    {
      subst_map = StringMap.add name ii accu;
      local_wire = subst_data.local_wire
    }

  (** acceder directement aux infos en fonction du nom et dimension *)
  let find name dim accu : subst_struct = 
    let dim_map = StringMap.find name accu.subst_map in
    IntMap.find dim dim_map

  (** trouver les variables de remplacement dans le cas d'une net_variable d'indexation entieres.
     Il est entendu qu'on doit l'avoir deja rencontree *)
  let unsafe_subst interface net_var_const map =
    match net_var_const with
    | Fresh i -> 
	begin
	  try
	    let vname = Printf.sprintf "fresh%d" i in
	    begin
	      match find vname 1 map with
	      | SIMPLE_subst sub -> [SIGNAL sub.subst_name]
	      | _ -> 
		  Message.message#double_utilisation_ident_bop2vlog vname;
		  failwith "unsafe_subst, vector <> simple"
	    end
	  with
	  | Not_found -> [SIGNAL "Not_found"]
	end
    | Simple vname ->
	begin
	  try
	    begin 
	      match find vname 1 map with
	      | SIMPLE_subst sub -> [SIGNAL sub.subst_name]
	      | _ ->
		  Message.message#double_utilisation_ident_bop2vlog vname;
		  failwith "unsafe_subst, vector <> simple"
	    end
	  with
	  | Not_found -> [SIGNAL "Not_found"]
	end 
    | Vecteur (line, name, int_index_list) -> 
	begin
	  try
	    let dim = List.length int_index_list in
	    let (expand, indexation) = mono_dim_vector_list name int_index_list in
	    let vlog_index = vlog_indexation_of_int_param_indexation indexation in
	    let f_fold accu t =
	      match find t dim map with
	      | SIMPLE_subst _ -> 
		  Message.message#double_utilisation_ident_bop2vlog t;
		  failwith "unsafe_subst, vector <> simple"
	      | VECTOR_subst vs ->
		  begin
		    (* En fonction du sens, on ne rend pas la meme chose *)
		    match vlog_index with
		    | INDEX _ -> accu@[VECTOR (t, false, vlog_index)]
		    | INTERVAL (a, b) ->
			begin
			  (* Savoir si c'est la definition du vecteur et s'il y a un clash *)
			  if a <= b
			  then 
			    let is_declaration = (a = vs.vector_min) & (b = vs.vector_max) in
			    accu@[VECTOR (t, is_declaration, vlog_index)]
			  else
			    (* dans les autres cas, il y a un clash de sens : on rend une liste d'index dans l'autre sens !*)
			    (* sauf s'il s'agit d'une substitution lors d'une interface ... ?? ... *)
			    if interface
			    then accu@[VECTOR (t, false, INTERVAL (a, b))]
			    else accu@(List.map (fun exp -> VECTOR (t, false, exp)) (List.rev (expand_vlog_indexation vlog_index)))
			end
		  end 
	    in List.fold_left f_fold [] expand 
	  with
	  | Not_found -> [SIGNAL "Not_found"]
	end
end  
(* ===================================================================== *)

(* ===================================================================== *)
(** Exercice de traduction des identifiants, des vecteurs, etc.. de bebop
    vers verilog. Produit des Warning quand on rencontre des restrictions
    de sens, etc...
    A partir d'une fonction debouclee, on produit l'interface verilog, 
    la collection des variables locales ainsi qu'une fonction de substitution
    d'un int param_net_variable list vers vlog_call_signal list.
    La substition ne produit pas de concat. En revanche, on produira
    une liste eclatée en cas de contradiction de sens des bits. *)
(* ===================================================================== *)
let interfaces_wire_and_substitution_of_fonction_debouclee (fd:fonction_debouclee) =
  (* Prevoir une generation de noms frais pour renommage de dimensions *)
  let fresh_var, _ = fresh_fct_factory (Printf.sprintf "mv_%d") in
  (* Structure vide *)
  let init = SubstMap.empty in
  (* parcours des noeuds, construction de la structure de donnee *)
  let fold_parcours accu = function
    | Fresh i ->
	begin
	  let vname = Printf.sprintf "fresh%d" i in
	  (* il faut voir si la structure comporte deja quelque chose pour ce nom *)
	  let vname_list = SubstMap.find_dim vname accu in
	  match vname_list with
	  | [] ->
	      begin
		(* On ajoute donc cette variable de dimension 1 dans la structure *)
		let sub = SIMPLE_subst
		  {
		    subst_name = vname
		  }
		in
		SubstMap.add vname 1 sub accu 
	      end
	  | li when List.mem 1 li -> accu (* On l'a deja indexé, il ne faut pas modifier la structure *)
	  | li ->
	      begin
		(* dim type clash pour verilog : il faut renommer et ajouter *)
		let very_fresh = fresh_var () in
		let sub = SIMPLE_subst
		  {
		    subst_name = very_fresh
		  }
		in
		SubstMap.add vname 1 sub accu
	      end
	end 

    | Simple vname ->
	begin
	  (* il faut voir si la structure comporte deja quelque chose pour ce nom *)
	  let vname_list = SubstMap.find_dim vname accu in
	  match vname_list with
	  | [] ->
	      begin
		(* On ajoute donc cette variable de dimension 1 dans la structure *)
		let sub = SIMPLE_subst
		  {
		    subst_name = vname
		  }
		in
		SubstMap.add vname 1 sub accu 
	      end
	  | li when List.mem 1 li -> accu (* On l'a deja indexé, il ne faut pas modifier la structure *)
	  | li ->
	      begin
		(* dim type clash pour verilog : il faut renommer et ajouter *)
		let very_fresh = fresh_var () in
		let sub = SIMPLE_subst
		  {
		    subst_name = very_fresh
		  }
		in
		SubstMap.add vname 1 sub accu
	      end
	end
	  
    | Vecteur (line, name, int_index_list) -> 
	begin
	  let dim = List.length int_index_list in
	  (* On ajoute donc ces vecteurs de dimension dim dans la structure *)
	  let (expand, indexation) = mono_dim_vector_list name int_index_list in
	  let vlog_index = vlog_indexation_of_int_param_indexation indexation in
	  let traite_vector accu expand_name = 
	      match SubstMap.find_dim expand_name accu with
	      | [] ->
		  begin
		    (* expand_name n'existe pas encore dans la structure *)
		    let sub = VECTOR_subst
		      (match vlog_index with
		       | INTERVAL (a, b) ->
			   if a < b
			   then
			     {
			       subst_vector_name = expand_name;
			       vector_min = a;
			       vector_max = b;
			     }
			   else
			     {
			       subst_vector_name = expand_name;
			       vector_min = b;
			       vector_max = a;
			     }
		       | INDEX i ->
			   {
			     subst_vector_name = expand_name;
			     vector_min = i;
			     vector_max = i;
			   }
		      )
		    in
		    SubstMap.add expand_name dim sub accu
		  end
	      | li when List.mem dim li -> 
		  begin
		    (* On a déjà ajouté ce vecteur de la bonne dimension dans la structure *)
		    (* reste à voir si les index correspondant sont dedans *)
		    try
		      begin
			match SubstMap.find expand_name dim accu with
			| SIMPLE_subst _ -> failwith "Vecteur <> Signal Clash vlogtools"
			| VECTOR_subst vs ->
			    begin
			      (* Il faut ajouter les index dans la structure *)
			      insert_vlog_indexation_in_vector_subst vlog_index vs;
			      accu (* qui est modifié par effet de bord cette fois *)
			    end
		      end
		    with
		    | Not_found -> failwith "Qui a un probleme dans subst vlogtools ?"
		  end
	      | li ->  
		  begin
		    (* Il faut renommer à cause d'un dim type clash pour verilog *)
		    let very_fresh = fresh_var () in
		    let sub = VECTOR_subst
		      (match vlog_index with
		       | INTERVAL (a, b) ->
			   if a < b
			   then
			     {
			       subst_vector_name = very_fresh;
			       vector_min = a;
			       vector_max = b;
			     }
			   else
			     {
			       subst_vector_name = very_fresh;
			       vector_min = b;
			       vector_max = a;
			     }
		       | INDEX i ->
			   {
			     subst_vector_name = very_fresh;
			     vector_min = i;
			     vector_max = i;
			   }
		      )
		    in
		    SubstMap.add expand_name dim sub accu
		  end
	  in List.fold_left traite_vector accu expand
	end
  in 
  let parcours = List.fold_left fold_parcours in
  let f_fold accu = function
    | line, _, (_, ent), (_, sor) -> 
	let accu2 = parcours accu ent in
	parcours accu2 sor
  in
  (* On repere deja les decorations entrantes et sortantes *)
  let _, entrees_decorees = fd.entrees_dcl_f and _, sorties_decorees = fd.sorties_dcl_f in
  let vars_init = parcours (parcours init entrees_decorees) sorties_decorees in
  let vars = List.fold_left f_fold vars_init fd.corps_dcl_f in
  let substitution_interface bebop_vars = concat_map (fun v -> SubstMap.unsafe_subst true v vars) bebop_vars in 
  let substitution bebop_vars = concat_map (fun v -> SubstMap.unsafe_subst false v vars) bebop_vars in
  let call_entrees = substitution_interface entrees_decorees in
  let interface_entree = List.map vlog_interface_signal_of_call_signal call_entrees in
  let call_sorties = substitution_interface sorties_decorees in
  let interface_sortie = List.map vlog_interface_signal_of_call_signal call_sorties in
  let set_interface = vlog_call_signal_set_of_list VlogCallSignalSet.empty (call_entrees@call_sorties) in
  let all_wire = SubstMap.get_all_vlog_call_signal vars in
  let (call_wire:vlog_call_signal list) = VlogCallSignalSet.elements (VlogCallSignalSet.diff all_wire set_interface) in
  let (wire:vlog_signal list) = List.map vlog_signal_of_call_signal call_wire in
  (interface_entree, interface_sortie, wire, substitution) ;;
(* ===================================================================== *)

(* ===================================================================== *)
(** A l'instar de CdsMaker.creer_fonction : la f_fold pour verilog *)
(* ===================================================================== *)
let creer_verilog_module arite_prim memory_arite env (fd:fonction_debouclee) vlog_name : vlog_module = 
  (* Gerer le nommage des noeuds verilog *) 
  let fresh_node, _ = fresh_fct_factory (Printf.sprintf "node%d") in
  (* On creer les interfaces, les wires locaux, et la fonction de substitution *)
  let interface_entree, interface_sortie, vlog_wire_locaux, vlog_substitution = interfaces_wire_and_substitution_of_fonction_debouclee fd
  in
  (* ne pas oublier de partager la clock *)
  let synchrone = ref false in
  let synchronize_module () = synchrone := true in
  let vlog_instances = 
    let vlog_instance_of_bebop_noeud_lineaire = function
      | line, portee_call, (_, entrees_noeud_decorees ), (sorties_bebop, sorties_noeud_decorees) ->
	  (* Substitution des variables vers leur representants verilog *)
	  let arite_sortie = List.length sorties_bebop in
	  let vlog_sign_input = vlog_substitution entrees_noeud_decorees 
	  and vlog_sign_output = vlog_substitution sorties_noeud_decorees in
	  begin
	    (* maintenant, il faut faire la difference selon la nature de portee_call *)
	    match portee_call with
	      
	    (* Tache systemes ignorees *)
	    | ExternalCall (appel, meth_ref_option, _, _)  when arite_sortie = 0 ->
		let chaine =
		  match meth_ref_option with
		  | None -> appel
		  | Some s -> Printf.sprintf "%s.%s" appel !s
		in
		Message.message#bebop_task_system_ignored fd.fichier_dcl_f line chaine;
		IGNORED_TASK chaine
	    | PipeCall (appel, _) when arite_sortie = 0 ->
		Message.message#bebop_task_system_ignored fd.fichier_dcl_f line appel;
		IGNORED_TASK appel
		
	    (* Probleme de compilation *)
	    | ExternalCall (appel, _, _, _) | PipeCall (appel, _) -> 
		Message.message#bloc_extern_for_compilation "bop2vlog" fd.fichier_dcl_f line appel;
		failwith "w-friendly"
	    | LocalCall loccall ->
		begin
		  (* En gros, faut savoir si c'est une primitive, une fonction, etc ... *)
		  (* le cas echeant, il faut recuperer ces infos dans l'environnement *)
		  (* voir la parente avec creer_fonction dans cdsmaker.ml *)
		  try
		    let infos_primitive = StringMap.find loccall arite_prim in
		    match fst infos_primitive with
		      
		    (* 0) garde de type par construction *)
		    | Input | Output | Regt | Regr _ -> failwith "garde de type construction vlogtools"
			
		    (* 1) Non supportes par la compilation *)
		    | PipeNode (appel, _, _)  
                    | ExternalNode (_, _, appel, _, _, _, _) -> 
			Message.message#bloc_extern_for_compilation "bop2vlog" fd.fichier_dcl_f line appel;
			failwith "w-friendly"

		    (* 2) Primitives bebop *)
		    | Mux -> INSTCALL ("bebop_mux", fresh_node (),  vlog_sign_output, vlog_sign_input)
			
		    (* registres : il faut ajouter l'horloge : du coup, la fonction elle-meme devient synchrone *)
		    | Reg ->
			begin
			  synchronize_module ();
			  INSTCALL ("bebop_reg", fresh_node (), vlog_sign_output, vlog_sign_input@[SIGNAL "clock"])
			end
		    | NReg -> failwith "TODO NREG in bop2vlog"

		    (* 3) Memoires : il faut aussi ajouter l'horloge *)
		    (* ICI, il faut aussi faire un relooking, avec une interface qu'on connait statiquement *)
		    | Rom (name, _) -> 
			begin
			  synchronize_module ();
			  (* Relook *)
			  let (ad, wl) = try List.assoc name memory_arite with Not_found -> failwith "memory arite vlogtools" in
			  let input_interface_expected = [ BUS ("addr", (0, (pred ad))); WIRE "clock" ] 
			  and output_interface_expected = [ BUS ("word", (0, (pred wl))) ] in
			  let output_relook = relook_vlog_signal_list output_interface_expected vlog_sign_output
			  and input_relook = relook_vlog_signal_list input_interface_expected (vlog_sign_input@[SIGNAL "clock"]) in
			  INSTCALL (Printf.sprintf "rom_%s" name, fresh_node (), output_relook, input_relook)
			end
		    | Ram (name, _) ->  
			begin
			  synchronize_module ();
			  (* Relook *)
			  let (ad, wl) = try List.assoc name memory_arite with Not_found -> failwith "memory arite vlogtools" in
			  let input_interface_expected = [ BUS ("read_addr", (0, pred ad)); 
							   BUS ("write_addr", (0, pred ad)); 
							   WIRE "en";
							   BUS ("data", (0, pred wl)) ; WIRE "clock"] 
			  and output_interface_expected =  [ BUS ("word", (0, pred wl)) ] in
			  let output_relook = relook_vlog_signal_list output_interface_expected vlog_sign_output
			  and input_relook = relook_vlog_signal_list input_interface_expected (vlog_sign_input@[SIGNAL "clock"]) in
			  INSTCALL (Printf.sprintf "ram_%s" name, fresh_node (), output_relook, input_relook)
			end

		    (* 4) Autres : compatibilite *)

		    (* assigns *)
		    | Id ->
			(* let count = Count.call_signal_list vlog_sign_output in *)
			let sig_in = CONCAT vlog_sign_input 
			and sig_out = CONCAT vlog_sign_output
			in
			ASSIGN (sig_out, ID sig_in)
 
		    | Gnd ->
			begin
			  let count = Count.call_signal_list vlog_sign_output in
			  match vlog_sign_output with
			  | [t] -> ASSIGN(t, GND count) 
			  | o -> ASSIGN (CONCAT vlog_sign_output, GND count)
			end
		    | Opt -> failwith "TODO Opt in bop2vlog"
		    | Vdd   
		    | Clock ->
			begin
			  let count = Count.call_signal_list vlog_sign_output in
			  match vlog_sign_output with
			  | [t] -> ASSIGN(t, VDD count) 
			  | o -> ASSIGN (CONCAT vlog_sign_output, VDD count)
			end
                  
		    (* primitives de base *)
		    | Not -> INSTCALL ("not", fresh_node (), vlog_sign_output, vlog_sign_input)
		    | Et  -> INSTCALL ("and", fresh_node (), vlog_sign_output, vlog_sign_input)
		    | Ou  -> INSTCALL ("or", fresh_node (), vlog_sign_output, vlog_sign_input)
		    | Xor -> INSTCALL ("xor", fresh_node (), vlog_sign_output, vlog_sign_input)

		  (* SINON *)
		  with
		    (* ce n'est pas une primitive *)
		  | Not_found ->
		      (* on remplace le nom avec la convention de nommage pour le developpement des fonctions a parametres *) 
		      let call_name = string_map (function | '[' | ']' -> '_' | o -> o) loccall in
		      begin 
			(* Alors, on essaye de voir si c'est un appel a une fonction de l'environnement *)
			try
			  let infos_vlog = StringMap.find call_name env in
			  (* On va pouvoir trouver les interfaces attendues par cette fonction *)
			  (* notamment savoir s'il faut ajouter l'horloge pour partage *)
			  let input_interface_expected = infos_vlog.vlog_entete.vlog_i_input
			  and output_interface_expected = infos_vlog.vlog_entete.vlog_i_output in
			  (* on va faire un relooking des variables decorees apres substitution *)
			  let input_sign_received, output_sign_received =
			    if infos_vlog.synchrone 
			    then (synchronize_module (); (vlog_sign_input@[SIGNAL "clock"], vlog_sign_output))
			    else (vlog_sign_input, vlog_sign_output)
			  in
			  let output_relook = relook_vlog_signal_list output_interface_expected output_sign_received
			  and input_relook = relook_vlog_signal_list input_interface_expected input_sign_received in
			  INSTCALL (call_name, fresh_node (), output_relook, input_relook)
			with
			  (* sinon, c'est une fonction indefinie, impossible d'apres les verifications Context *)
			| Not_found -> failwith "Qui ne fait pas un bon job dans vlogtools ?"
		      end

		end
	  end
    in
    List.map vlog_instance_of_bebop_noeud_lineaire fd.corps_dcl_f
  in
  {
    synchrone = !synchrone; 
    vlog_entete = 
      { 
	vlog_i_name = vlog_name;
	vlog_i_output = interface_sortie;
	vlog_i_input = if !synchrone then interface_entree@[WIRE "clock"] else interface_entree;
	vlog_i_reg = [];
	vlog_i_wire = vlog_wire_locaux
      };
    vlog_instances = vlog_instances;
    vlog_initial = [];
    vlog_posedge_clk = [];
    vlog_always = []
  }
(* ===================================================================== *)


(* ===================================================================== *)
(** Creer un memory_arite env a partir d'un tableau d'export memoire *)
(* ===================================================================== *)
let memory_arite_of_export_memoire ex =
  let rec aux accu i =
    if i < 0 
    then accu
    else
      let name = 
	match ex.(i).type_dcl_m with
	| ROM_decl name -> name
	| RAM_decl name -> name
      in
      aux ((name, (ex.(i).arite_entree_dcl_m, ex.(i).arite_sortie_dcl_m))::accu) (pred i)
  in aux [] (pred (Array.length ex))
(* ===================================================================== *)

(* ===================================================================== *)
(** Creer les environnements complets bebop et verilog a partir du tableau d'arite
    des primitives, et de la liste des declarations des fonctions une fois debouclees.
    On recolte au passage la liste des index dans l'environnement verilog des fonctions
    dont on veut creer un test bench *)
(* ===================================================================== *)
let environnement_and_benches_verilog arite_primitive memory_arite fcts_debouclees = 
  let new_bebop_fct = creer_fonction arite_primitive in
  let new_vlog_module = creer_verilog_module arite_primitive memory_arite in 
  let stack_order = Stack.create () in
  let f_fold (bebop_env, vlog_env, benches) fct_debouclee =
    let bebop_name = fct_debouclee.nom_dcl_f in
    (* dans le cas verilog, on remplace les crochets par des underscores *)
    let verilog_name = string_map (function | '[' | ']' -> '_' | o -> o) bebop_name in
    (* On cree la fonction bebop, verification de contexte *)
    let bebop_fonction = new_bebop_fct bebop_env fct_debouclee in
    (* On cree le module verilog *)
    let verilog_module = new_vlog_module vlog_env fct_debouclee verilog_name in
    (* On met a jour la liste des benches, selon ce que nous disent les attributs *)
    let lower_att = List.map String.lowercase fct_debouclee.attribut_dcl_f in
    let new_benches =
      let bench_request = function
	| "main" | "vlogbench" | "vlogtestbench" | "verilog" -> true
	| _ -> false
      in
      if List.exists bench_request lower_att 
      then verilog_name::benches
      else benches 
    in
    (* ajout de la fonction dans l'ordre *)
    Stack.push verilog_name stack_order;
    (* creation du nouvel accu pour fold *)
    (StringMap.add bebop_name bebop_fonction bebop_env),
    (StringMap.add verilog_name verilog_module vlog_env),
    new_benches
  in
  (* On a pris une pile, de sorte que l'extraction vers une liste est terminale *)
  let list_of_stack_order () =
    let rec aux accu =  
      if Stack.is_empty stack_order then accu else aux ((Stack.pop stack_order)::accu)
    in aux []
  in
  (* gestion de l'appel en fold sur la liste des fcts_debouclees *)
  match List.fold_left f_fold (StringMap.empty, StringMap.empty, []) fcts_debouclees with
  | a, b, c -> { bebop_env = a; vlog_env = b; vlog_fcts_order = list_of_stack_order () }, c
(* ===================================================================== *)

(* ===================================================================== *)
(** Partie production de code verilog : une ligne de commentaire pour les 
    entete, a utiliser avec center *)
(* ===================================================================== *)
let line = "// "^(String.make 50 '=')^" //"
(* ===================================================================== *)

(* ===================================================================== *)
(** Quel nom on choisit pour reperer les fichiers des memoires *)
(* ===================================================================== *)
let list_file_name_of_type_memoire = function 
  | ROM_decl name -> "rom"^(String.lowercase name)^".list"
  | RAM_decl name -> "ram"^(String.lowercase name)^".list"
(* ===================================================================== *)

(* ===================================================================== *)
(** Production du fichier principal contenant la traduction de la net-list
    en bebop-hdl vers une net-list en verilog a plat sans generics *)
(* ===================================================================== *)
let production_verilog_lib analyse vtrad filename =  
  let oc = open_out filename in
  let prod = Printf.fprintf oc "%s" in
  let prodln = Printf.fprintf oc "%s\n" in
  (* entete *)
  prodln line;
  prodln (center (Printf.sprintf " VERILOG - BEBOP 1.0 " ) line);
  prodln line;
  prodln "";
  prodln (Printf.sprintf "// bop2vlog %s : %s\n" Message.version (Message.get_date ()));
  prod "/*\n";
  prod (Printf.sprintf " %s : macro-generated file from bebop-hdl files :\n" filename);
  let f_iter modul = prod (Printf.sprintf "\t+ %s\n" modul) in
  List.iter f_iter analyse.y_modules_bebop;
  prod "*/\n\n";
  
  (* Apres l'entete, on a besoin des primitives bebop *)
  prodln "// From Bebop-hdl\n";
  List.iter (fun m -> prodln (VlogSyntax.of_module m)) VlogModules.all; 
  
  (* Ensuite, des primitives memoires *)
  let f_iter_mem dec =
    let vlog_mod = 
      let file_dest = list_file_name_of_type_memoire dec.type_dcl_m in 
      match dec.type_dcl_m with
      | ROM_decl name -> VlogModules.synch_rom ("rom_"^name) dec.arite_entree_dcl_m dec.arite_sortie_dcl_m file_dest
      | RAM_decl name ->
	  begin
	    match dec.description_entree_dcl_m with
	    | None -> VlogModules.free_synch_ram ("ram_"^name) dec.arite_entree_dcl_m dec.arite_sortie_dcl_m
	    | Some _ -> VlogModules.synch_ram ("ram_"^name) dec.arite_entree_dcl_m dec.arite_sortie_dcl_m file_dest
	  end
    in 
    prodln (VlogSyntax.of_module vlog_mod)
  in
  if analyse.y_table_export_memoires = [||]
  then ()
  else
    begin
      prodln "// Memories, ROM & RAM\n";
      Array.iter f_iter_mem analyse.y_table_export_memoires;
    end; 

  (* Apres quoi, il s'agit de produire le code du reste *)
  let f_iter_module m =
    try
      let infos_module = StringMap.find m vtrad.vlog_env in
      prodln (VlogSyntax.of_module infos_module);
      prodln "";
    with
    | Not_found -> failwith "Qui ne fait pas son boulot dans vlogtools ?"
  in
  prodln line;
  prodln "";
  List.iter f_iter_module vtrad.vlog_fcts_order;

  (* c'est la fin *)
  
  flush oc;   
  close_out oc
(* ===================================================================== *)

(* ===================================================================== *)
(** Production automatique d'un module de test bench pour un module present
    dans l'environnement verilog des fonctions provenant de la traduction
    depuis bebop-hdl *)
(* ===================================================================== *)
let production_test_bench vtrad lib_file bench filename = 
  let oc = open_out filename in
  let prod = Printf.fprintf oc "%s" in
  let prodln = Printf.fprintf oc "%s\n" in
  (* production de fresh pour le nom des entrees sorties *)
  (* 
     let fresh_input, _ = fresh_fct_factory (Printf.sprintf "inp%d") in
     let fresh_output, _ = fresh_fct_factory (Printf.sprintf "out%d") in
  *)
  (* entete *)
  prodln line;
  prodln (center (Printf.sprintf " VERILOG TEST BENCH - BEBOP 1.0 " ) line);
  prodln line;
  prodln "";
  prodln (Printf.sprintf "// bop2vlog %s : %s\n" Message.version (Message.get_date ()));
  prod (Printf.sprintf "// %s : macro-generated test bench for module \"%s\"\n" filename bench);
  prodln "";
  prodln (Printf.sprintf "`include \"%s\"\n" lib_file);

  (* trouver dans l'environnement le bloc qui nous interresse *)
  begin
    try
      let infos_module = StringMap.find bench vtrad.vlog_env in
      let test_name = (String.capitalize infos_module.vlog_entete.vlog_i_name)^"VlogTestBench" in
      (* ICI, pour pouvoir mettre des commentaires comme on veut, on n'utilise pas directement VlogSyntax.of_module *)
      (* les sorties sont des wire, les entrees des reg *)
      (* On commence par nommer les variables necessaires *)
      let list_entrees = List.map (fun sig_brut -> vlog_call_signal_of_interface_signal sig_brut) infos_module.vlog_entete.vlog_i_input in
      let list_sorties = List.map (fun sig_brut -> vlog_call_signal_of_interface_signal sig_brut) infos_module.vlog_entete.vlog_i_output in
      let list_sign_entrees = List.map vlog_signal_of_call_signal list_entrees in
      let list_sign_sorties = List.map vlog_signal_of_call_signal list_sorties in
      (* on cree ainsi l'entete *)
      let vlog_entete =
	{
	  vlog_i_name = test_name;
	  (* Un module de test bench n'a ni d'entree ni de sortie *)
	  vlog_i_output = [];
	  vlog_i_input = [];
	  (* en reg sont les entrees du bloc a tester + la clock *)
	  vlog_i_reg = if infos_module.synchrone then list_sign_entrees else (SIGNAL "clock")::list_sign_entrees;
	  (* en wire, on met les sorties du bloc a tester *) 
	  vlog_i_wire = list_sign_sorties
	}
      in
      (* production de l'entete *)
      prodln (VlogSyntax.of_entete vlog_entete);
      prodln "\t// instance of component";
      prodln ("\t"^(VlogSyntax.of_instance (INSTCALL (infos_module.vlog_entete.vlog_i_name, "inst1", list_sorties, list_entrees))));
      prodln "";

      (* initialement, mettre l'horloge a zero, et les entrees aussi *)
      (* la mis a zero de clock se fait tout seul dans le cas de bloc synchrones *)
      let input_init_0_task = ASSIGN_NON_BLOC (CONCAT list_entrees, GND (Count.call_signal_list list_entrees)) in
      let clock_0_task = ASSIGN_NON_BLOC (SIGNAL "clock", GND 1) in
      let tasks = if infos_module.synchrone then [input_init_0_task] else [clock_0_task; input_init_0_task] in
      prodln "\tinitial begin";
      List.iter (fun t -> prodln ("\t\t"^(VlogSyntax.of_task t))) tasks;
      prodln "\tend";
      prodln "";

      (* gestion de l'horloge *)
      prodln "\t// Clock generator";
      prodln "\talways #10 clock = ~clock;";
      prodln "";

      (* gestion de l'impression des sorties selon le protocole pipe 01 *)
      prodln "\t// Pipe 01 protocol - output on stdout";
      prodln "\t// Bit reverse like in bebop : LSB on the left";
      prodln "\talways @(posedge clock) begin";
      prodln "\t\t#5 // signals propagation";
      let list_sorties_LSB =
	let f_concat_map = function
	  | VECTOR (s, _, ((INTERVAL (a, b)) as inter)) when a < b ->
	      List.map (fun index -> VECTOR (s, false, index)) (expand_vlog_indexation inter) 
	  | o -> [o]
	in concat_map f_concat_map list_sorties 
      in
      let format = string_cat_init (List.length list_sorties_LSB) (fun _ -> (Printf.sprintf "%cb" '%')) in
      let args = (string_of_list VlogSyntax.of_call_signal ", " "" ");" list_sorties_LSB) in
      prodln (Printf.sprintf "\t\t$display(\"%s\", %s" format args);
      prodln "\tend";
      prodln "";
      
      (* gestion de l'entree *)
      prodln "\t// Input generator";
      let entree = VlogSyntax.of_call_signal (CONCAT (List.filter (fun s -> match s with SIGNAL "clock" -> false | _ -> true) list_entrees)) in
      if String.length entree > 0
      then
	begin
	  prodln "\talways begin";
	  prodln "\t\t// INSERT YOUR STIMULUS HERE";
	  prodln "\t\t// default : a simple counter, incr each cycle";
	  prodln "\t\t// A PLI-VPI system task : $pipe(..input..) would be great for co-simulation !!";
	  let entree = VlogSyntax.of_call_signal (CONCAT (List.rev (List.filter (fun s -> match s with SIGNAL "clock" -> false | _ -> true) list_entrees))) in
	  let count_task = Printf.sprintf "\t\t#20 %s <= %s + 1;" entree entree 
	  in
	  prodln count_task;
	  prodln "\tend";
	end
      else
	begin
	  prodln "\t// No input for this module";
	end;
      prodln "";

      (* end of module *)
      prodln "endmodule";

    with
    | Not_found -> failwith "qui ne fait pas son boulot de test bench dans vlogtools ?"
  end;

  flush oc; 
  close_out oc
(* ===================================================================== *)
